perm filename MATCH.118[AID,LSP]1 blob
sn#589620 filedate 1981-05-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 the matching function
C00005 00003 The Simple Pattern Matcher
C00033 00004 The Instantiator
C00037 00005 Losing interns for the stupid COMPLR
C00051 ENDMK
C⊗;
;;;;;;;;;; the matching function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;; $r, ⊗r - same as RESTRICT
;;; (restrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given the list
;;; that is being considered for that variable as its argument
;;; (irestrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given each element of the list
;;; that is being considered for that variable as its argument
;;; (done incrementally). So %MATCH will apply these predicates as
;;; it scans the input.
;;; $ir,⊗ir - same as irestrict
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;; possible match between p and d (by different *-variable
;;; bindings.
;;*PAGE
;;; The Simple Pattern Matcher
(DECLARE (SETSYNTAX 35. 2 35.))
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS))
;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL)
;;; (MATCH <pat> <data> <initial alist, optional>)
(DEFUN %MATCH %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(%%MATCH (ARG 1) (ARG 2) NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3))))) )) NIL))
;;; (%CONTINUE-MATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN %CONTINUE-MATCH %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(%%MATCH (ARG 1)(ARG 2) NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4))))) ))
T))
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to match against %/#CD if %/#P and %/#D match (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
(MACRODEF %%CHAR1 (ATOM)
;; returns the 1st character of an atom.
(COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))
(MACRODEF REAL-ATOM (%/#X)(OR (AND %/#X (ATOM %/#X)) (HUNKP %/#X)))
(MACRODEF ALL-TRUE (FUN %/#L)
(APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (%Q%)(COND ((FUNCALL FUN %Q%) T))))
%/#L)))
(MACRODEF RESTRICTP (%/#X) (AND (NOT (ATOM %/#X))
(MEMQ (CAR %/#X) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))
(DEFUN %%MATCH (%/#P %/#D %/#CP %/#CD %/#ALIST)
(PROG NIL
MATCH
(OR
(COND
;;; no more pattern
((AND (NULL %/#P) (NULL %/#CP))
;;; so there had better be no more data
(COND ((AND (NULL %/#D)(NULL %/#CD))
;;; if this is a rematch, we back up for next try
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
;;; more data loses
((*THROW '%/#DECISION-POINT NIL ))))
((NULL %/#P)
;;; if %/#P is null, but %/#D isn't, something is wrong
(COND (%/#D (*THROW '%/#DECISION-POINT NIL ))
(T (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
(GO MATCH))))
((AND (NULL %/#D)
(NOT (RESTRICTP (CAR %/#P))))
;;; if %/#D is null and %/#P isn't, we can still win
(COND ((OR (ATOM %/#P)
(MEMQ (CAR %/#P) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR)))
;;; if %/#P=?<var> or = nil
(SETQ %/#P (NCONS %/#P) %/#D '(NIL))
(GO MATCH))
((EQ (CAR %/#P) '*)
;;; %/#P=(* ...) could work if (CDR %/#P) is all *-variables
(SETQ %/#P (CDR %/#P))
(GO MATCH))
((EQ (%%CHAR1 (CAR %/#P)) '*)
;;; we succeed if (CAR %/#P) = (*<var> ...) and *<var> matched 0 elements.
((LAMBDA(%T%)
(COND (%T% (SETQ %/#P (APPEND (CDR %T%)(CDR %/#P)))
(GO MATCH))
(T (COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) NIL %/#CP %/#CD
(CONS (CONS (CAR %/#P) NIL)
%/#ALIST)) )
(SET (CAR %/#P) NIL)
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))))
(ASSQ (CAR %/#P) %/#ALIST)))
(T (*THROW '%/#DECISION-POINT ()))
))
((OR (ATOM %/#P) (REAL-ATOM %/#D))
;;; here we listify things if necessary
(SETQ %/#P (NCONS %/#P) %/#D (NCONS %/#D))
(GO MATCH))
;;; restrictions
((AND (NOT (ATOM (CAR %/#P)))
(MEMQ (CAAR %/#P) '($R RESTRICT ⊗R))
(EQ (%%CHAR1 (CADAR %/#P)) '?)
(NOT (NULL %/#D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (%/#PRED) (COND ((FUNCALL %/#PRED (CAR %/#D))
T))))
(CDDAR %/#P))))
(COND
((EQ (CADAR %/#P) '?)
;;; normal case of ($r ? ...)
(SETQ %/#P (CDR %/#P) %/#D (CDR %/#D))
(GO MATCH))
((EQ (%%CHAR1 (CADAR %/#P)) '?)
;;; case of ($r ?foo ...)
((LAMBDA (%T%)
(COND (%T% (SETQ %/#P (CONS (CDR %T%) (CDR %/#P)))
(GO MATCH))
(T (COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P)(CDR %/#D) %/#CP %/#CD
(CONS (CONS (CADAR %/#P)
(CAR %/#D))
%/#ALIST))
)
(SET (CADAR %/#P) (CAR %/#D))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))))
(ASSQ (CADAR %/#P) %/#ALIST)))
((EQ (%%CHAR1 (CADAR %/#P)) '=)
;;; case of ($r ?foo ...)
(SETQ %/#P (CONS (CADAR %/#P) (CDR %/#P)))
(GO MATCH))))
((AND (NOT (ATOM (CAR %/#P)))
(MEMQ (CAAR %/#P) '($R RESTRICT ⊗R)))
(COND ((EQ (CADAR %/#P) '*)
(COND ((NULL (CDR %/#P))
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (%/#Q)
(COND
((FUNCALL %/#Q %/#D)
T))))
(CDDAR %/#P)))
(SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
(GO MATCH))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T ((LAMBDA (%/#L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ %/#L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
(%/#D %/#D (CDR %/#D)))
((NULL %/#L) %/#D)))
(COND ((NULL %/#D)
(SETQ %/#P (CDR %/#P))
(GO MATCH))))
(T (SETQ %/#L NIL)))
;;; try all possibilities
(DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
(%/#D %/#D (CDR %/#D))
(%/#E (CONS NIL %/#D) (CDR %/#E)))
((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND
((FUNCALL %/#Q %/#L)
T))))
(CDDAR %/#P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) %/#D %/#CP %/#CD
%/#ALIST)
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS %/#L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T ))))))) NIL))))
((EQ (%%CHAR1 (CADAR %/#P)) '*)
((LAMBDA (%T%)
(COND (%T% (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND ((FUNCALL %/#Q
(CDR %T%))
T))))
(CDDAR %/#P)))
(SETQ %/#P (APPEND (CDR %T%) (CDR %/#P)))
(GO MATCH))
(T (*THROW '%/#DECISION-POINT NIL ))))
((NULL (CDR %/#P))
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND
((FUNCALL
%/#Q
%/#D)
T))))(CDDAR %/#P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CAR %/#CP) (CAR %/#CD) (CDR %/#CP)
(CDR %/#CD)
(CONS (CONS (CADAR %/#P) %/#D)
%/#ALIST))
)
(SET (CADAR %/#P) %/#D)
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T ((LAMBDA(%/#L)
(COND (%/#CONTINUE
(SETQ %/#L (SYMEVAL (CAR %/#P)))
(SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
(%/#D %/#D (CDR %/#D)))
((NULL %/#L) %/#D)))
(COND ((NULL %/#D)
(SETQ %/#P (CDR %/#P))
(GO MATCH))))
(T (SETQ %/#L NIL)))
(DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
(%/#D %/#D (CDR %/#D))
(%/#E (CONS NIL %/#D) (CDR %/#E)))
((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND ((FUNCALL %/#Q %/#L)
T))))
(CDDAR %/#P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) %/#D %/#CP %/#CD
(CONS (CONS (CADAR %/#P) %/#L)
%/#ALIST))
)
(SET (CADAR %/#P) %/#L)
(*THROW '%/#DECISION-POINT T ))))))) NIL))))
(ASSQ (CADAR %/#P) %/#ALIST)) )
((EQ (%%CHAR1 (CADAR %/#P)) '=)
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL
(SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))))
(T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))
%/#ALIST (CONS (CONS VAR (SYMEVAL VAR))
%/#ALIST)))))
(ASSQ VAR %/#ALIST)))
(IMPLODE (CDR (EXPLODE (CADAR %/#P)))))
(GO MATCH)) ))
((AND (NOT (ATOM (CAR %/#P)))
(MEMQ (CAAR %/#P) '($IR IRESTRICT ⊗IR)))
(COND ((EQ (CADAR %/#P) '*)
(COND ((NULL (CDR %/#P))
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (%/#Q)
(COND
((ALL-TRUE %/#Q %/#D)
T))))
(CDDAR %/#P)))
(SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
(GO MATCH))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T ((LAMBDA (%/#L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ %/#L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
(%/#D %/#D (CDR %/#D)))
((NULL %/#L) %/#D)))
(COND ((NULL %/#D)
(SETQ %/#P (CDR %/#P))
(GO MATCH))))
(T (SETQ %/#L NIL)))
;;; try all possibilities
(DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
(%/#F (CAR %/#D)(CAR %/#D))
(%/#D %/#D (CDR %/#D))
(%/#E (CONS NIL %/#D) (CDR %/#E)))
((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND
((OR (NULL %/#L)
(FUNCALL %/#Q %/#F))
T))))
(CDDAR %/#P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) %/#D %/#CP %/#CD
%/#ALIST)
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS %/#L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T ))))
(T (*THROW '%/#DECISION-POINT NIL ))))) NIL))))
((EQ (%%CHAR1 (CADAR %/#P)) '*)
((LAMBDA (%T%)
(COND (%T% (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND ((ALL-TRUE %/#Q %T%)
T))))
(CDDAR %/#P)))
(SETQ %/#P (APPEND (CDR %T%) (CDR %/#P)))
(GO MATCH))
(T (*THROW '%/#DECISION-POINT NIL ))))
((NULL (CDR %/#P))
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND
((ALL-TRUE
%/#Q
%/#D)
T))))(CDDAR %/#P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CAR %/#CP) (CAR %/#CD) (CDR %/#CP)
(CDR %/#CD)
(CONS (CONS (CADAR %/#P) %/#D)
%/#ALIST))
)
(SET (CADAR %/#P) %/#D)
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T ((LAMBDA(%/#L)
(COND (%/#CONTINUE
(SETQ %/#L (SYMEVAL (CAR %/#P)))
(SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
(%/#D %/#D (CDR %/#D)))
((NULL %/#L) %/#D)))
(COND ((NULL %/#D)
(SETQ %/#P (CDR %/#P))
(GO MATCH))))
(T (SETQ %/#L NIL)))
(DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
(%/#F (CAR %/#D)(CAR %/#D))
(%/#D %/#D (CDR %/#D))
(%/#E (CONS NIL %/#D) (CDR %/#E)))
((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (%/#Q)
(COND ((OR (NULL %/#L)
(FUNCALL %/#Q %/#F))
T))))
(CDDAR %/#P)))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) %/#D %/#CP %/#CD
(CONS (CONS (CADAR %/#P) %/#L)
%/#ALIST))
)
(SET (CADAR %/#P) %/#L)
(*THROW '%/#DECISION-POINT T ))))
(T (*THROW '%/#DECISION-POINT NIL ))))) NIL))))
(ASSQ (CADAR %/#P) %/#ALIST)) )
((EQ (%%CHAR1 (CADAR %/#P)) '=)
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL
(SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))))
(T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
(CDR %/#P))
%/#ALIST (CONS (CONS VAR (SYMEVAL VAR))
%/#ALIST)))))
(ASSQ VAR %/#ALIST)))
(IMPLODE (CDR (EXPLODE (CADAR %/#P)))))
(GO MATCH)) ))
((OR (EQUAL (CAR %/#P) (CAR %/#D)) (EQ (CAR %/#P) '?))
;;; easiest case
(SETQ %/#P (CDR %/#P) %/#D (CDR %/#D))
(GO MATCH))
((EQ (%%CHAR1 (CAR %/#P)) '?)
;;; (?foo ...)
((LAMBDA (%T%)
(COND (%T% (SETQ %/#P (CONS (CDR %T%) (CDR %/#P)))
(GO MATCH))
(T (COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P)(CDR %/#D) %/#CP %/#CD
(CONS (CONS (CAR %/#P)
(CAR %/#D))
%/#ALIST))
)
(SET (CAR %/#P) (CAR %/#D))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))))
(ASSQ (CAR %/#P) %/#ALIST)))
((EQ (CAR %/#P) '*)
;;; (* ...)
(COND ((NULL (CDR %/#P))
(SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
(GO MATCH))
(T ((LAMBDA (%/#L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ %/#L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
(%/#D %/#D (CDR %/#D)))
((NULL %/#L) %/#D)))
(COND ((NULL %/#D)
(SETQ %/#P (CDR %/#P))
(GO MATCH))))
(T (SETQ %/#L NIL)))
;;; try all possibilities
(DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
(%/#D %/#D (CDR %/#D))
(%/#E (CONS NIL %/#D) (CDR %/#E)))
((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) %/#D %/#CP %/#CD
%/#ALIST)
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS %/#L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))NIL))))
((EQ (%%CHAR1 (CAR %/#P)) '*)
;;; similar for (*foo ...)
((LAMBDA (%T%)
(COND (%T% (SETQ %/#P (APPEND (CDR %T%) (CDR %/#P)))
(GO MATCH))
((NULL (CDR %/#P))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CAR %/#CP) (CAR %/#CD) (CDR %/#CP)
(CDR %/#CD)
(CONS (CONS (CAR %/#P) %/#D)
%/#ALIST))
)
(SET (CAR %/#P) %/#D)
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T ((LAMBDA(%/#L)
(COND (%/#CONTINUE
(SETQ %/#L (SYMEVAL (CAR %/#P)))
(SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
(%/#D %/#D (CDR %/#D)))
((NULL %/#L) %/#D)))
(COND ((NULL %/#D)
(SETQ %/#P (CDR %/#P))
(GO MATCH))))
(T (SETQ %/#L NIL)))
(DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
(%/#D %/#D (CDR %/#D))
(%/#E (CONS NIL %/#D) (CDR %/#E)))
((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((*CATCH '%/#DECISION-POINT
(%%MATCH (CDR %/#P) %/#D %/#CP %/#CD
(CONS (CONS (CAR %/#P) %/#L)
%/#ALIST))
)
(SET (CAR %/#P) %/#L)
(*THROW '%/#DECISION-POINT T ))))) NIL))))
(ASSQ (CAR %/#P) %/#ALIST)) )
((EQ (%%CHAR1 (CAR %/#P)) '=)
;;; (=?foo ...)
((LAMBDA (%T%)
(COND ((EQ (CAR %T%) '?)
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL (SETQ %/#P (CONS (CDR VAL) (CDR %/#P))))
(T
(SETQ %/#P
(CONS (SYMEVAL VAR) (CDR %/#P)))))
(GO MATCH))
(ASSQ VAR %/#ALIST)))
(IMPLODE %T%)))
(T
((LAMBDA (VAR)
((LAMBDA (VAL)
(COND (VAL (SETQ %/#P (APPEND (CDR VAL) (CDR %/#P))))
(T
(SETQ %/#P
(APPEND (SYMEVAL VAR) (CDR %/#P)))))
(GO MATCH))
(ASSQ VAR %/#ALIST)))
(IMPLODE %T%)))))
(CDR (EXPLODE (CAR %/#P)))))
((AND (NOT (ATOM (CAR %/#P)))
(OR (NULL (CAR %/#D))(NOT (ATOM (CAR %/#D)))))
;;; the big recursion
;;; notice that we want nil to be a list here, not an atom
;;; since ((*) ...) (nil ...) needs a chance
(SETQ
%/#CP (CONS (CDR %/#P) %/#CP)
%/#CD (CONS (CDR %/#D) %/#CD)
%/#P (CAR %/#P) %/#D (CAR %/#D))
(GO MATCH)))
(*THROW '%/#DECISION-POINT NIL ))))
(DEFUN %CHAR1 (%/#ATOM)
;; returns the 1st character of an atom.
(COND ((EQ (TYPEP %/#ATOM) 'SYMBOL) (GETCHAR %/#ATOM 1.))))
(DEFUN %MATCH-LOOKUP (%/#X)
(CDR (ASSQ %/#X %/#ALIST)))
;;*page
;;; The Instantiator
(MACRODEF %CHAR1 (ATOM)
;; returns the 1st character of an atom.
(COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))
(DECLARE (SPECIAL -SEEN-))
(DEFUN %INSTANTIATE (PAT)
((LAMBDA (-SEEN-)
(%INSTANTIATE1 PAT))
()))
(DEFUN %INSTANTIATE1 (PAT)
;;; instantiates pattern.
;;; ?ce : the ce
;;; ?<atom> : value of ?<atom> used
;;; *<atom> : value of *<atom> spliced in
(COND ((ATOM PAT)
(COND ((EQ PAT '?CE) (SUBST NIL NIL %/#CE))
((EQ PAT '?) '-QUESTION-MARK-)
((EQ PAT '*)'-STAR-)
((MEMQ PAT '(? *)) PAT)
((EQ (%CHAR1 PAT) '→) (IMPLODE (CDR (EXPLODE PAT))))
((MEMQ (%CHAR1 PAT) '(* ?))
(COND ((BOUNDP PAT)
(%%COPY (SYMEVAL PAT)))
(T PAT)))
(PAT)))
((HUNKP PAT) PAT)
((EQ (CAR PAT) '*)
(CONS '-STAR- (%INSTANTIATE1 (CDR PAT))))
((EQ (%CHAR1 (CAR PAT)) '*)
(APPEND
(COND ((BOUNDP (CAR PAT))
(SYMEVAL (CAR PAT)))
(T (CAR PAT)))
(%INSTANTIATE1 (CDR PAT))))
((MEMQ (CAR PAT) '(RESTRICT $R ⊗R IRESTRICT $IR ⊗IR))
(%INSTANTIATE1 (CADR PAT)))
((MEMQ PAT -SEEN-) PAT)
(T (PUSH PAT -SEEN-)
(CONS (%INSTANTIATE1 (CAR PAT))
(%INSTANTIATE1 (CDR PAT))))))
(DEFUN %%COPY (X)
((LAMBDA (-SEEN-)
(%%COPY1 X)) ()))
(DEFUN %%COPY1 (X)
(COND ((NULL X) ())
((ATOM X) X)
((HUNKP X) X)
((MEMQ X -SEEN-) X)
(T (PUSH X -SEEN-)
(CONS (%%COPY1 (CAR X))
(%%COPY1 (CDR X))))))
;;*page
;;; Losing interns for the stupid COMPLR
(intern '/←)
(intern 'then)
(intern 'do)
(intern 'execute)
(intern 'defmacro)
(intern 'meanwhle)
(intern 'let/!)